#  File src/library/stats/R/reshape.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2013 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

reshape <-
    function(data, varying = NULL, v.names = NULL, timevar = "time",
             idvar = "id",
             ids = 1L:NROW(data), times = seq_along(varying[[1L]]),
             drop = NULL, direction, new.row.names = NULL,
             sep = ".",
             split = if (sep == "") {
                 list(regexp = "[A-Za-z][0-9]", include = TRUE)
             } else {list(regexp = sep, include = FALSE, fixed = TRUE)})
{

    if (!is.character(sep) || length(sep) != 1L)
        stop("'sep' must be a character string")

    ix2names <- function(ix)
        if (is.character(ix)) ix else names(data)[ix]

    guess <- function(nms,re = split$regexp,drop = !split$include,
                      fixed=if(is.null(split$fixed)) FALSE else split$fixed)
    {
        if (drop)
            nn <- do.call("rbind",strsplit(nms, re, fixed = fixed))
        else
            nn <- cbind(substr(nms, 1L, regexpr(re,nms)),
                        substr(nms, regexpr(re,nms) + 1L, 10000L))

        if (ncol(nn) != 2L)
            stop("failed to guess time-varying variables from their names")


        vn <- unique(nn[,1])
        v.names <- split(nms, factor(nn[, 1L], levels = vn))
        times <- unique(nn[, 2L])
        attr(v.names,"v.names") <- vn
        tt <- tryCatch(as.numeric(times), warning = function(w) times)
        attr(v.names,"times") <- tt
        v.names
    }

    reshapeLong <-
        function(data, varying, v.names = NULL, timevar, idvar,
                 ids = 1L:NROW(data), times,
                 drop = NULL,new.row.names = NULL)
        {
            ll <- unlist(lapply(varying,length))
            if (any(ll != ll[1L]))
                stop("'varying' arguments must be the same length")
            if (ll[1L] != length(times))
                stop("'lengths(varying)' must all match 'length(times)'")

            if (!is.null(drop)) {
                if (is.character(drop))
                    drop <- names(data) %in% drop
                data <- data[, if (is.logical(drop)) !drop else -drop, drop = FALSE]
            }

            ## store information for back-transformation.
            undoInfo <- list(varying = varying, v.names = v.names,
                             idvar = idvar, timevar = timevar)

            ## multiple id variables
            if (length(idvar) > 1L) {
                ids <- interaction(data[, idvar], drop=TRUE)
            } else if (idvar %in% names(data)) {
                ids <- data[, idvar]
            }

            d <- data
            all.varying <- unlist(varying)
            d <- d[,!(names(data) %in% all.varying), drop = FALSE]

            if (is.null(v.names))
                v.names <- vapply(varying, `[`, 1L, FUN.VALUE=character(1L))
                
            rval <- do.call(rbind, lapply(seq_along(times), function(i) {
                d[, timevar] <- times[i]
                varying.i <- vapply(varying, `[`, i, FUN.VALUE=character(1L))
                d[, v.names] <- data[, varying.i]
                if (is.null(new.row.names))
                    row.names(d) <- paste(ids, times[i], sep = ".")
                else
                    row.names(d) <- new.row.names[(i-1L)*NROW(d) + 1L:NROW(d)]
                d
            }))

            if (length(idvar) == 1L && !(idvar %in% names(data))) {
                rval[, idvar] <- ids
            }

            attr(rval,"reshapeLong") <- undoInfo
            return(rval)
        } ## re..Long()

    reshapeWide <- function(data,timevar,idvar,varying = NULL,v.names = NULL,
                            drop = NULL,new.row.names = NULL)
    {
        if (!is.null(drop)) {
            if (is.character(drop)) drop <- names(data) %in% drop
            data <- data[, if (is.logical(drop)) !drop else -drop, drop = FALSE]
        }
        undoInfo <- list(v.names = v.names,  timevar = timevar,idvar = idvar)

        orig.idvar <- idvar
        if (length(idvar) > 1L) {
            repeat({
                tempidname <- basename(tempfile("tempID"))
                if (!(tempidname %in% names(data))) break
            })
            data[, tempidname] <- interaction(data[, idvar], drop=TRUE)
            idvar <- tempidname
            drop.idvar <- TRUE
        } else drop.idvar <- FALSE

        ## times <- sort(unique(data[,timevar]))
        ## varying and times must have the same order
        times <- unique(data[, timevar])
        if (anyNA(times))
            warning("there are records with missing times, which will be dropped.")
        undoInfo$times <- times

        if (is.null(v.names))
            v.names <- names(data)[!(names(data) %in% c(timevar, idvar, orig.idvar))]

        if (is.null(varying)) varying <- outer(v.names, times, paste, sep = sep)
        if (is.list(varying)) varying <- do.call("rbind", varying)

        undoInfo$varying <- varying

        keep <- !(names(data) %in% c(timevar, v.names, idvar, orig.idvar))
        if(any(keep)) {
            rval <- data[keep]
            tmp <- data[, idvar]
            really.constant <-
                unlist(lapply(rval,
                              function(a) all(tapply(a, as.vector(tmp),
                                                     function(b) length(unique(b)) == 1L))))
            if (!all(really.constant))
                warning(gettextf("some constant variables (%s) are really varying",
                                 paste(names(rval)[!really.constant],collapse = ",")), domain = NA)
        }

        rval <- data[!duplicated(data[, idvar]),
                     !(names(data) %in% c(timevar, v.names)), drop = FALSE]

        for(i in seq_along(times)) {
            thistime <- data[data[, timevar] %in% times[i], ]
            tab <- table(thistime[, idvar])
            if (any(tab > 1L))
                warning(sprintf("multiple rows match for %s=%s: first taken",
                                timevar, times[i]), domain = NA)
            rval[, varying[, i]] <-
                thistime[match(rval[, idvar], thistime[, idvar]), v.names]
        }

        if (!is.null(new.row.names)) row.names(rval) <- new.row.names

        ## temporary id variable to be dropped.
        if (drop.idvar) rval[, idvar] <- NULL

        ## information for back-transformation
        attr(rval,"reshapeWide") <- undoInfo

        rval
    } ## re..Wide()

    ## Begin reshape()

    if (missing(direction)) {
        undo <- c("wide", "long")[c("reshapeLong", "reshapeWide")
                                  %in% names(attributes(data))]
        if (length(undo) == 1L) direction <- undo
    }
    direction <- match.arg(direction, c("wide", "long"))


    switch(direction,
           "wide" =
       {
           back <- attr(data,"reshapeLong")
           if (missing(timevar) && missing(idvar) && !is.null(back)) {
               reshapeWide(data, idvar = back$idvar, timevar = back$timevar,
                           varying = back$varying, v.names = back$v.names,
                           new.row.names = new.row.names)
           } else {
               reshapeWide(data, idvar = idvar, timevar = timevar,
                           varying = varying, v.names = v.names, drop = drop,
                           new.row.names = new.row.names)
           }

       },
           "long" =
       {
           if (missing(varying)) {
               back <- attr(data,"reshapeWide")
               if (is.null(back))
                   stop("no 'reshapeWide' attribute, must specify 'varying'")
               varying <- back$varying
               idvar <- back$idvar
               timevar <- back$timevar
               v.names <- back$v.names
               times <- back$times
           }

           if (is.matrix(varying)) {
               ## <FIXME split.matrix>
               varying <- split(c(varying), row(varying))
           }
           if (is.null(varying))
               stop("'varying' must be nonempty list or vector")
           if(is.atomic(varying)) {
               varying <- ix2names(varying) # normalize
               if (missing(v.names))
                   varying <- guess(varying)
               else {
                   if (length(varying) %% length(v.names))
                       stop("length of 'v.names' does not evenly divide length of 'varying'")
                   ntimes <- length(varying) %/% length(v.names)
                   if (missing(times))
                       times <- seq_len(ntimes)
                   else if (length(times) != ntimes)
                       stop("length of 'varying' must be the product of length of 'v.names' and length of 'times'")
                   varying <- split(varying, rep(v.names, ntimes))
                   attr(varying, "v.names") <- v.names
                   attr(varying, "times") <- times
               }
           }
           else varying <- lapply(varying, ix2names)

           ## This must happen after guess()
           if (missing(v.names) && !is.null(attr(varying,"v.names"))) {
               v.names <- attr(varying, "v.names")
               times <- attr(varying, "times")
           }
           reshapeLong(data, idvar = idvar, timevar = timevar,
                       varying = varying, v.names = v.names, drop = drop,
                       times = times, ids = ids, new.row.names = new.row.names)
       })
}
